home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
WAFPEGTP
/
AWINDOW.PAS
next >
Wrap
Pascal/Delphi Source File
|
1994-01-16
|
19KB
|
709 lines
unit awindow;
{
some simple windowing code, derived from various public domain sources
rml
January 1994
note, needs fastscrn.obj to be linked in
Copyright (C) 1992 Dr Ross Lazarus
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Dr Ross Lazarus is the original copyright holder of this code.
Email: rossl@gmu.wh.su.edu.au
Mail: Department of Community Medicine,
Westmead Hospital
Westmead, NSW 2145
Australia
Fax: (+61 2) 689 1049
}
interface
uses dos,crt;
CONST Maxwindow = 64; { No. of slots on the window stack }
Linebytes = 160; { Bytes/screen line in 80 col modes}
Sidestep : integer = 3; { Horiz. offset for `walking' menus }
Downstep : integer = 1; { Vert. offset for `walking' menus }
Root = 0; { WinID of the Root window}
TYPE String80 = STRING[80];
Btype = (Rev,Norm,Drev,Dnorm,none); { Border type }
Stype = (Shad,Noshad); { Shadow present }
WinID = 0..Maxwindow; { Window handle }
Curtype = (Off, Big, Small);
var
bfb,bff,sf,sb,fc,bc,ifc,ibc,backfillf,backfillb : byte;
{
major bug fixed rml september 1989
the screen image captured by getmem was not being freed up
freemem added in movewindowdata
}
{-----------------------------------------------------------
An extension of the Turbo window manager to support
multiple windows.
------------------------------------------------------------}
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Add a title to the top left window border.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE WindowTitle(Title: String80);
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create and display a new window. Its handle can be obtained
from Lastwin.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
PROCEDURE Window(Ux,Uy,Lx,Ly,Fore,Back: Byte; Border: Btype;
Shadow: Stype);
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Destroy window and its contents permanently.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE CloseWindow;
implementation
type
DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
var
BaseOfScreen : Word; {Base address of video memory}
WaitForRetrace : Boolean; {Check for snow on color cards?}
Speed : longint; {delay factor for growbox routine}
{$L FASTSCRN}
{$F+}
Procedure FastWrite(Col,Row,Attr:byte; St:string); external;
Procedure PlainWrite(Col,Row:byte; St:string); external;
Function CurrentDisplay: DisplayType; external;
Function CurrentVideoMode: Byte; external;
{$F-}
Procedure InitFastWrite;
{
Initializes WaitForRetrace and BaseOfScreen
}
begin {InitFastWrite}
if CurrentVideoMode = 7 then
BaseOfScreen := $B000 {Mono}
else
BaseOfScreen := $B800; {Color}
WaitForRetrace := (CurrentDisplay = CGA);
end;
{InitFastWrite}
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
These primitive functions return single or double
horizontal line segments, for use in string expresions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
FUNCTION Horiz(Len: Byte): String80;
CONST Hineseg = '────────────────────────────────────────────────────────────────────────────────';
BEGIN
Horiz := Copy(Hineseg, 1, Len)
END;
FUNCTION DHoriz(Len: Byte): String80;
CONST Hlineseg = '════════════════════════════════════════════════════════════════════════════════';
BEGIN
DHoriz := Copy(Hlineseg, 1, Len)
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Draw single or double horizontal and vertical lines of
specified length.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE Hline(X1, Y1, Len: Byte);
BEGIN
fastwrite(X1, Y1,textattr,Horiz(Len));
END;
PROCEDURE Vline(X1, Y1, Len: Byte);
VAR I: Byte;
BEGIN
FOR I := Y1 TO Y1+Len DO
fastwrite(X1, I,textattr,'│');
END;
PROCEDURE DHline(X1, Y1, Len: Byte);
BEGIN
fastwrite(X1, Y1,textattr,DHoriz(Len));
END;
PROCEDURE DVline(X1, Y1, Len: Byte);
VAR I: Byte;
BEGIN
FOR I := Y1 TO Y1+Len DO
fastwrite(X1, I,textattr,'║');
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Draw single or double boxes of specified width and depth.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE Box(X1, Y1, Wide, Deep: Byte);
BEGIN
fastwrite(X1, Y1,textattr, '┌'+Horiz(Wide)+'┐');
Vline(X1, Y1+1, Deep);
Vline(X1+Wide+1, Y1+1, Deep);
fastwrite(X1, Y1 + succ(deep),textattr,'└'+Horiz(Wide)+'┘');
END;
PROCEDURE DBox(X1, Y1, Wide, Deep: Byte);
BEGIN
fastwrite(X1, Y1 ,textattr, '╔'+Dhoriz(Wide)+'╗');
Dvline(X1, Y1+1, Deep);
Dvline(X1+Wide+1, Y1+1, Deep);
fastwrite(X1, Y1 + succ(deep),textattr,'╚'+Dhoriz(Wide)+'╝');
end;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Return larger or smaller of two integer values.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
FUNCTION Max(A, B: Integer): Integer;
BEGIN
IF A > B THEN Max := A ELSE Max := B
END;
FUNCTION Min(A, B: Integer): Integer;
BEGIN
IF A < B THEN Min := A ELSE Min := B
END;
{- - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - -
Return a string of Num spaces.
- - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - -}
FUNCTION Spaces(Num: Word): String80;
CONST Blanks = ' ';
BEGIN
if (num > 0) then
Spaces := Copy(Blanks, 1, Num)
else
spaces := '';
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Return the argument string stripped of leading and
trailing (but not embedded) spaces.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
FUNCTION NoSpaces(S: STRING): STRING;
VAR Lead, Trail: Integer;
BEGIN
Lead := 1;
WHILE S[Lead] = ' ' DO inc(Lead);
Trail := Length(S);
WHILE S[Trail]= ' ' DO dec(Trail);
NoSpaces := Copy(S, Lead, Trail - Lead + 1)
END;
function trim(trime : String) : String;
{ trim trailing blanks by adjusting the length byte at trime[0] }
const
blank = ' ';
var
l : integer;
begin
l := ord(trime[0]);
while (l > 0) and (trime[l] = blank) do
l := pred(l);
trime[0] := chr(l);
trim := trime;
end; { trim }
VAR Shadfore, Shadback: Byte; { Set global shadow colours }
Vseg: Word; { Start segment of video buffer }
{===========================================================}
procedure initcol;
{
fake some colors
}
var
regs : registers;
mhf,mhb,mf,mb,mbf,mbb,bf,bb,tf,tb,wf,wb,sf,sb : integer;
begin
{ Check for monochrome or colour adaptor}
Regs.AX := $0F00;
Intr($10, Regs);
IF Regs.AL = 7 THEN
{If (BaseOfScreen = $B000) then}
begin { mono monitor }
mhf := darkgray;
mhb := blue;
mf := lightgray;
mb := blue;
mbf := black;
mbb := lightgray;
bf := lightgray;
bb := blue;
tf := lightgray;
tb := blue;
wf := darkgray;
wb := blue;
end
else
begin { colour }
mhf := lightcyan;
mhb := blue;
mf := yellow;
mb := blue;
mbf := yellow;
mbb := red;
bf := lightcyan;
bb := blue;
tf := yellow;
tb := blue;
wf := yellow;
wb := red;
end;
fc := tf;
bc := tb;
ifc := wf;
ibc := wb;
bfb := tb;
bff := tf;
sf := darkgray;
sb := black;
shadfore := sf;
shadback := sb;
end;
TYPE Dirn = (Toheap,Fromheap); { Direction flag for MoveWindowData}
WinPtr = ^Windowdescriptor;
Windowdescriptor
= RECORD
Parent: WinID;
Ux,Uy,Lx,Ly,Fore,Back,X,Y: Byte;
Border: Btype;
Shadow: Stype;
P: Pointer;
END;
VAR Regs: Registers;
Top, Active: WinID; { Stack pointer and marker }
W: ARRAY[WinID] OF WinPtr; { Window stack }
{-----------------------------------------------------------
These procedures and functions redefine their equivalents
in the Turbo Crt unit. NOTE: Windmax, Windmin and
TextAttr were variables not functions in Crt.
------------------------------------------------------------}
FUNCTION WindMax: Word;
BEGIN
WindMax := pred(W[Active]^.Ly) * 256 + pred(W[Active]^.Lx);
END;
FUNCTION WindMin: Word;
BEGIN
WindMin := pred(W[Active]^.Uy) * 256 + pred(W[Active]^.Ux);
END;
FUNCTION WhereX: Byte;
BEGIN
WhereX := W[Active]^.X
END;
FUNCTION WhereY: Byte;
BEGIN
WhereY := W[Active]^.Y
END;
PROCEDURE Gotoxy(X,Y: Byte);
BEGIN
W[Active]^.X := X;
W[Active]^.Y := Y;
Crt.Gotoxy(X,Y)
END;
PROCEDURE Textcolour(Colour: Byte);
BEGIN
W[Active]^.Fore := Colour;
Crt.Textcolor(Colour)
END;
PROCEDURE Textbackground(Colour: Byte);
BEGIN
W[Active]^.Back := Colour;
Crt.Textbackground(Colour)
END;
FUNCTION TextAttr: Byte;
BEGIN
TextAttr := W[Active]^.Fore + W[Active]^.Back * 16
END;
{-----------------------------------------------------------
More convenient substitutes for TextAttr; return
foreground and background separately.
------------------------------------------------------------}
FUNCTION FCol: Byte;
BEGIN
FCol := W[Active]^.Fore
END;
FUNCTION BCol: Byte;
BEGIN
BCol := W[Active]^.Back
END;
{-----------------------------------------------------------
Return current cursor coordinates relative to whole
screen.
------------------------------------------------------------}
FUNCTION AbsX: Byte;
BEGIN
AbsX := W[Active]^.Ux+WhereX
END;
FUNCTION AbsY: Byte;
BEGIN
AbsY := W[Active]^.Uy+WhereY
END;
{-----------------------------------------------------------
Return cursor coordinates for next `walking' position.
------------------------------------------------------------}
FUNCTION AutoX: Byte;
BEGIN
AutoX := AbsX+Sidestep;
END;
FUNCTION AutoY: Byte;
BEGIN
AutoY := AbsY+Downstep;
END;
{-----------------------------------------------------------
Return top of stack and currently selected windows.
------------------------------------------------------------}
FUNCTION Lastwin: Byte;
BEGIN
Lastwin := Top
END;
FUNCTION Selwin: Byte;
BEGIN
Selwin := Active
END;
{-----------------------------------------------------------
Make window whose handle is Wnum the currently selected
window.
------------------------------------------------------------}
PROCEDURE SelectWindow(Wnum: WinID);
BEGIN
WITH W[Wnum]^ DO
BEGIN
Active := Wnum;
Textcolour(Fore);
TextBackground(Back);
IF (Wnum = Root) then
Crt.Window(1,1,80,25) { Root window has no border}
else
if ((border = none) and (shadow = noshad)) then
Crt.Window(Ux,Uy,Lx,Ly)
else
Crt.Window(Ux+1,Uy+1,Lx-1,Ly-1);
Gotoxy(X,Y);
END;
END;
{-----------------------------------------------------------
Draw a drop shadow at right and bottom edge of the selected
window. Modifies video buffer contents directly, bypassing
BIOS.
------------------------------------------------------------}
PROCEDURE DrawShadow(Fore, Back: Byte);
VAR I: Byte;
BEGIN
FOR I := W[Active]^.Uy TO W[Active]^.Ly DO
Mem[Vseg:I*Linebytes+W[Active]^.Lx*2+1] := Back*16+Fore;
FOR I := W[Active]^.Ux TO W[Active]^.Lx DO
Mem[Vseg:W[Active]^.Ly*Linebytes+I*2+1] := Back*16+Fore
END;
{-----------------------------------------------------------
Move the previous screen contents covered by a new window
To or From a storage space allocated on the heap.
------------------------------------------------------------}
PROCEDURE MoveWindowData(Wnum: WinID; Direction: Dirn);
VAR I,Deep,Wide,Startaddr: Word;
BEGIN
{ Calculate window dimensions}
Deep := succ(W[Wnum]^.Ly) - W[Wnum]^.Uy;
Wide := (succ(W[Wnum]^.Lx) - W[Wnum]^.Ux) * 2;
{ Calculate start offset of first window line in video buffer}
Startaddr:= pred(W[Wnum]^.Uy) * Linebytes + pred(W[Wnum]^.Ux)*2;
{ Must save area covered by shadow too, if there is one}
IF (W[Wnum]^.Shadow = Shad)
THEN BEGIN
inc(Deep);
inc(Wide,2);
END;
IF Direction = Toheap
THEN BEGIN
{ Allocate storage space}
Getmem(W[Wnum]^.P, Deep * Wide * 2);
{ Move screen data to heap, one line at a time}
FOR I := 0 TO pred(Deep) DO
Move(Mem[Vseg:Startaddr + I*Linebytes],
Mem[Seg(W[Wnum]^.P^)
:Ofs(W[Wnum]^.P^)+I*Wide], Wide)
END
ELSE { Move stored heap data back to screen buffer}
begin
FOR I := 0 TO pred(Deep) DO
Move(Mem[Seg(W[Wnum]^.P^)
:Ofs(W[Wnum]^.P^)+ I*Wide],
Mem[Vseg:Startaddr + I*Linebytes], Wide);
(* major fix - this line frees up the no longer needed screen image *)
(* off the heap rml September 1989 *)
freemem(W[Wnum]^.P, Deep * Wide * 2);
end;
END;
{- - - - - - - - - - - - - - - - --- - - - - - - - -
Create window image on screen.
- - - - - - - - - - - - - -- - - - - - - - - - - - - -}
PROCEDURE DrawWindow;
BEGIN
Crt.Window(1, 1, 80, 25);
WITH W[Active]^ DO
BEGIN
IF (Border = Rev) OR (Border = Drev)
THEN BEGIN
Crt.Textcolor(ifc);
Crt.TextBackground(ibc);
IF Border = Rev
THEN Box(Ux, UY, Lx-Ux-1, Ly-Uy-1)
ELSE
if (border <> none) then
DBox(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
END
ELSE BEGIN
Crt.Textcolor(bff);
Crt.TextBackground(bfb);
IF Border = Norm
THEN Box(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
ELSE if (border <> none) then
DBox(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
END;
IF Shadow = Shad THEN DrawShadow(Shadfore, Shadback)
END
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create and display a new window. Its handle can be obtained
from Lastwin.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
PROCEDURE Window(Ux,Uy,Lx,Ly,Fore,Back: Byte; Border: Btype;
Shadow: Stype);
var
deep,wide : byte;
c : char;
BEGIN
{Pre-increment stack pointer}
Inc(Top);
{Check for stack overflow}
IF Top > Maxwindow
THEN BEGIN
SelectWindow(Root);
Write('Too many windows: max permitted is ', Maxwindow+1);
clreol;
Halt(2);
END;
Deep := succ(Ly) - Uy;
Wide := (succ(Lx) - Ux) * 2;
if (maxavail < (deep*wide*2)) then
BEGIN
SelectWindow(Root);
Writeln('Not enough memory to create required window');
clreol;
halt(1);
END;
{Allocate space for window descriptor }
New(W[Top]);
{ Fill in new descriptor}
if (shadow <> noshad) then
begin
ux := min(ux,79);
uy := min(uy,24);
lx := max(lx,1);
ly := max(ly,1);
W[Top]^.Ux := max(Ux,1); { "Bounce off" screen edges}
W[Top]^.Uy := max(uy,1);
W[Top]^.Lx := Min(Lx, 79);
W[Top]^.Ly := Min(Ly, 24);
end
else
begin
ux := min(ux,80);
uy := min(uy,25);
lx := max(lx,1);
ly := max(ly,1);
W[Top]^.Ux := max(Ux,1); { "Bounce off" screen edges}
W[Top]^.Uy := max(uy,1);
W[Top]^.Lx := Min(Lx, 80);
W[Top]^.Ly := Min(Ly, 25);
end;
W[Top]^.Fore := Fore;
W[Top]^.Back := Back;
W[Top]^.X := 1;
W[Top]^.Y := 1;
if (w[top]^.ly > 24) or (w[top]^.lx >= 79) then
shadow := noshad;
W[Top]^.Border := Border;
W[Top]^.Shadow := Shadow;
W[Top]^.Parent := Active;
Active := Top;
MoveWindowData(Active, Toheap);
DrawWindow;
SelectWindow(Active);
ClrScr
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Add a title to the top left window border.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE WindowTitle(Title: String80);
var
tlen,spos : integer;
BEGIN
title := trim(title);
tlen := length(title);
Crt.Window(1, 1, 80, 25);
WITH W[Active]^ DO
BEGIN
IF (Border = Rev) OR (Border = Drev)
THEN
BEGIN
Crt.Textcolor(ifc);
Crt.TextBackground(ibc)
END
ELSE
BEGIN
Crt.Textcolor(bff);
Crt.TextBackground(bfb)
END;
spos := ux + ((lx - ux) div 2) - (tlen div 2);
Crt. GotoXY(succ(spos), Uy);
write(title);
end;
SelectWindow(Active)
END;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Destroy window and its contents permanently.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
PROCEDURE CloseWindow;
BEGIN
IF Top > 0 { Cannot close Root window!}
THEN BEGIN
MoveWindowData(Top,Fromheap); { Erase window image + free memory }
Active := W[Top]^.Parent; { Reinstate parent window}
Dispose(W[Top]^.P); { Free up screen data }
Dispose(W[Top]); { Free up descriptor}
Dec(Top); { Pop stack}
SelectWindow(Active)
END
END;
procedure winit;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Initialise window system.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
BEGIN
{ Check for monochrome or colour adaptor}
Regs.AX := $0F00;
Intr($10, Regs);
IF Regs.AL = 7 THEN Vseg := $B000 ELSE Vseg := $B800;
{ Initialise stack pointer}
Top := 0;
{ Set up descriptor for Root window}
New(W[Root]);
W[Root]^.Parent := Root;
W[Root]^.Ux := 1;
W[Root]^.Uy := 1;
W[Root]^.Lx := 80;
W[Root]^.Ly := 25;
W[Root]^.Fore := White;
W[Root]^.Back := Black;
W[Root]^.X := crt.wherex;
W[Root]^.Y := crt.wherey;
WITH W[Root]^ DO
BEGIN
Active := root;
Textcolour(Fore);
TextBackground(Back);
end; {* patch rml 7/8/91 to stop screen clearing *}
END;
begin
winit;
initcol;
initfastwrite;
speed := 200;
end.